Pascal Super Library/Pascal Super Library (CW International)(1997).bin/TSR/TSRSRC35/RELEASE.PAS

Pascal/Delphi Source File | 1993-10-21 | 23KB | 711 lines

{**************************************************************************
*   RELEASE - Releases memory above the last MARK call made.              *
*   Copyright (c) 1986,1993 Kim Kokkonen, TurboPower Software.            *
*   May be freely distributed and used but not sold except by permission. *
***************************************************************************
*   Version 1.0 2/8/86                                                    *
*     original public release                                             *
*     (thanks to Neil Rubenking for an outline of the method used)        *
*   :                                                                     *
*   long intervening history                                              *
*   :                                                                     *
*   Version 3.0 9/24/91                                                   *
*     make compatible with DOS 5                                          *
*     add Quiet option                                                    *
*     close open file handles of released blocks                          *
*     update for new WATCH behavior                                       *
*     increase number of supported memory blocks to 256                   *
*     add support for upper memory blocks                                 *
*   Version 3.1 11/4/91                                                   *
*     no change                                                           *
*   Version 3.2 11/22/91                                                  *
*     generalize method of accessing high memory                          *
*     reverse order in which memory blocks are released to work           *
*       correctly with the 386MAX high memory manager                     *
*     merge blocks in high memory after release (QEMM doesn't)            *
*   Version 3.3 1/8/92                                                    *
*     add /H to use high memory optionally                                *
*     new features for parsing and getting command line options           *
*   Version 3.4 2/14/92                                                   *
*     fix hang that occurs when QEMM LOADHI didn't have space to          *
*       load a mark high                                                  *
*   Version 3.5 10/18/93                                                  *
*     modify RestoreEMSMap to deal with EMS blocks for which a mapping    *
*       context has been stored                                           *
*     solve problem with RELEASE /U for a MARK loaded high with QEMM 7.0  *
*     solve problem with RELEASE /U for a MARK loaded high with 386MAX    *
***************************************************************************
*   telephone: [phone], CompuServe: 76004,2611.                      *
*   requires Turbo version 6 or 7 to compile.                             *
***************************************************************************}

{$R-,S-,I-,V-,B-,F-,A-,E-,N-,G-,X-}
{$M 16384,0,655360}

program ReleaseTSR;
  {-Restore system to state it had when a MARK was placed}

uses
  Dos,
  MemU,
  Ems,
  Xms;

var
  Blocks : BlockArray;
  markBlock, BlockMax : BlockType;
  markPsp : Word;
  StartMcb : Word;
  HiMemSeg : Word;

  markName : String[127];

  ReturnCode : Word;
  OptUseHiMem, UseHiMem, DealWithEMS, KeepMark,
  MemMark, FilMark, Quiet : Boolean;
  Keys : string[16];

  TrappedBytes : LongInt;

  MarkEHandles : Word;
  CurrEHandles : Word;
  MarkEmsHandles : PageArrayPtr;
  CurrEmsHandles : PageArrayPtr;

  {Save areas read in from file mark}
  Vectors : array[0..1023] of Byte;
  EGAsavTable : array[0..7] of Byte;
  IntComTable : array[0..15] of Byte;
  ParentSeg : Word;
  ParentLen : Word;
  McbP : ^McbGroup;

  procedure Abort(msg : String);
    {-Halt in case of error}
  begin
    WriteLn(msg);
    Halt(1);
  end;

  procedure NoRestoreHalt(ReturnCode : Word);
    {-Replace Turbo halt with one that doesn't restore any interrupts}
  begin
    Close(Output);
    asm
      mov ah,$4C
      mov al, byte(ReturnCode)
      int $21
    end;
  end;

  function FindMark(markName, MarkID : String;
                    MarkOffset : Word;
                    var MemMark, FilMark : Boolean;
                    var b : BlockType) : Boolean;
    {-Find the last memory block matching idstring at offset idoffset}
  var
    BPsp : Word;
    PassedFileMark : Boolean;

    function HasIDstring(segment : Word;
                         idString : String;
                         idOffset : Word) : Boolean;
      {-Return true if idstring is found at segment:idoffset}
    var
      len : Byte;
      tString : String;
    begin
      len := Length(idString);
      tString[0] := Chr(len);
      Move(Mem[segment:idOffset], tString[1], len);
      HasIDstring := (tString = idString);
    end;

    function GetMarkName(segment : Word) : String;
      {-Return a cleaned up mark name from the segment's PSP}
    var
      tString : String;
      tlen : Byte absolute tString;
    begin
      Move(Mem[segment:$80], tString[0], 128);
      while (tlen > 0) and ((tString[1] = ' ') or (tString[1] = ^I)) do
        Delete(tString, 1, 1);
      while (tlen > 0) and ((tString[tlen] = ' ') or (tString[tlen] = ^I)) do
        dec(tlen);
      GetMarkName := StUpcase(tString);
    end;

    function MatchMemMark(segment : Word;
                          markName : String;
                          var b : BlockType) : Boolean;
      {-Return true if MemMark is unnamed or matches current name}
    var
      FoundIt : Boolean;
      tString : String;
    begin
      tString := GetMarkName(segment);
      if markName <> '' then begin
        FoundIt := (tString = markName);
        if not FoundIt and not UseHiMem then
          if (tString <> '') and (tString[1] = ProtectChar) then
            {Current mark is protected, stop searching}
            b := 1;
      end else if (tString <> '') and (tString[1] = ProtectChar) then begin
        {Stored mark name is protected}
        FoundIt := False;
        {Stop checking}
        b := 1;
      end else if tString = '' then
        {Unnamed release and unnamed mark}
        FoundIt := True
      else begin
        {Unnamed release and named mark, match only if didn't pass file mark}
        FoundIt := not PassedFileMark;
        {Stop searching if no match}
        if not FoundIt then
          B := 1;
      end;
      if not FoundIt then
        dec(b);
      MatchMemMark := FoundIt;
    end;

    function MatchFilMark(segment : Word;
                          markName : String;
                          var b : BlockType) : Boolean;
      {-Return true if FilMark is unnamed or matches current name}
    var
      FoundIt : Boolean;
    begin
      if markName <> '' then begin
        FoundIt := (GetMarkName(segment) = markName);
        if FoundIt then
          {Assure named file exists}
          FoundIt := ExistFile(markName);
      end else begin
        {File marks must be named on RELEASE command line}
        FoundIt := False;
        PassedFileMark := True;
      end;
      if not FoundIt then
        dec(B);
      MatchFilMark := FoundIt;
    end;

  begin
    {Scan from the last block down to find the last MARK TSR}
    b := BlockMax;
    MemMark := False;
    FilMark := False;
    PassedFileMark := False;
    repeat
      BPsp := Blocks[B].Psp;
      if (Blocks[B].Mcb+1 <> BPsp) or (BPsp = PrefixSeg) then
        {Don't match any non-program block or this program}
        dec(b)
      else if HasIDstring(BPsp, NmarkID, NmarkOffset) then begin
        {A net mark, can't release it here}
        if UseHiMem then
          {Keep looking}
          dec(b)
        else
          {Stop looking}
          b := 0;
      end else if HasIDstring(BPsp, MarkID, MarkOffset) then
        {An in-memory mark}
        MemMark := MatchMemMark(BPsp, markName, b)
      else if HasIDstring(BPsp, FmarkID, FmarkOffset) then
        {A file mark}
        FilMark := MatchFilMark(BPsp, markName, b)
      else
        {Not a mark}
        dec(b);
    until (b < 1) or MemMark or FilMark;
    FindMark := MemMark or FilMark;
  end;

  procedure ReadMarkFile(markName : String);
    {-Read the mark file info into memory}
  var
    McbCount : Word;
    f : file;
  begin
    Assign(f, markName);
    Reset(f, 1);
    if IoResult <> 0 then
      Abort('Error opening mark file');

    {Read the vector table from the mark file, into a temporary memory area}
    BlockRead(f, Vectors, 1024);

    {Read the BIOS miscellaneous save areas into temporary tables}
    BlockRead(f, EGAsavTable, 8);
    BlockRead(f, IntComTable, 16);
    BlockRead(f, ParentSeg, 2);
    BlockRead(f, ParentLen, 2);

    {Read the stored EMS handles, if any}
    BlockRead(f, MarkEHandles, SizeOf(Word));
    GetMem(MarkEmsHandles, SizeOf(HandlePageRecord)*MarkEHandles);
    BlockRead(f, MarkEmsHandles^, SizeOf(HandlePageRecord)*MarkEHandles);

    {Read the stored Mcb table}
    BlockRead(f, McbCount, SizeOf(Word));
    GetMem(McbP, SizeOf(Word)+2*SizeOf(Word)*McbCount);
    BlockRead(f, McbP^.Mcbs, 2*SizeOf(Word)*McbCount);
    McbP^.Count := McbCount;

    if IoResult <> 0 then
      Abort('Error reading mark file');
    Close(f);

    if not KeepMark then
      {Delete the mark file so it causes no mischief later}
      Erase(f);
  end;

  procedure InitMarkInfo;
    {-Set up information from mark in memory}
  begin
    MarkEHandles := MemW[markPsp:EMScntOffset];
    MarkEmsHandles := Ptr(markPsp, EMSmapOffset);
    McbP := Ptr(markPsp, EMSmapOffset+4*MarkEHandles);
  end;

  procedure CopyVectors;
    {-Put interrupt vectors back into table}
  var
    PSeg : Word;
    PLen : Word;
  begin
    IntsOff;

    {Restore the main interrupt vector table}
    if FilMark then
      Move(Vectors, Mem[0:0], 1024)
    else
      Move(Mem[markPsp:VectorOffset], Mem[0:0], 1024);

    IntsOn;

    {Restore misc save areas}
    if FilMark then begin
      Move(EGAsavTable, Mem[$40:$A8], 8);
      Move(IntComTable, Mem[$40:$F0], 16);
      PSeg := ParentSeg;
      PLen := ParentLen;
    end else begin
      Move(Mem[markPsp:EGAsavOffset], Mem[$40:$A8], 8);
      Move(Mem[markPsp:IntComOffset], Mem[$40:$F0], 16);
      PSeg := MemW[markPsp:ParentOffset];
      PLen := MemW[markPsp:ParLenOffset];
    end;

    {Restore the parent address}
    if ValidPsp(HiMemSeg, PSeg, PLen) then begin
      {Don't restore parent if it no longer exists (applies to QEMM LOADHI)}
      MemW[PrefixSeg:$16] := PSeg;
      if not UseHiMem then
        {Programs loaded into high memory have strange termination addresses}
        Move(Mem[0:4*$22], Mem[PrefixSeg:$0A], 4); {Int 22 addresses}
    end;

    {Move the old break/error addresses into this program}
    Move(Mem[0:4*$23], Mem[PrefixSeg:$0E], 8); {Int 23,24 addresses}
  end;

  procedure MarkBlocks(markBlock : BlockType);
    {-Mark those blocks to be released}

    procedure BatchWarning(b : BlockType);
      {-Warn about the trapping effect of batch files}
    var
      t : BlockType;
    begin
      {WriteLn('Memory space for TSRs installed prior to batch file');} {!!}
      {WriteLn('will not be released until batch file completes.');}    {!!}
      {WriteLn;}                                                        {!!}
      ReturnCode := 1;
      {Accumulate number of bytes temporarily trapped}
      for t := 1 to b do
        if Blocks[t].releaseIt then
          inc(TrappedBytes, LongInt(MemW[Blocks[t].mcb:3]) shl 4);
    end;

    procedure MarkBlocksAbove;
      {-Mark blocks above the mark}
    var
      b : BlockType;
    begin
      for b := 1 to BlockMax do
        with Blocks[b] do
          if (b >= markBlock) and (mcb+1 = psp) and (memw[psp:$16] = psp) then begin
            {Don't release blocks owned by master COMMAND.COM}
            releaseIt := False;
            BatchWarning(b);
          end else if KeepMark then
            {Release all but RELEASE and the mark}
            releaseIt := (psp <> PrefixSeg) and (psp > markPsp)
          else
            releaseIt := (psp <> PrefixSeg) and (psp >= markPsp);
    end;

    procedure MarkUnallocatedBlocks;
      {-Mark blocks that weren't allocated at time of mark}
    var
      TopSeg : Word;
      b : BlockType;
      m : BlockType;
      Found : Boolean;
    begin
      {Find last low memory mcb}
      TopSeg := TopOfMemSeg-1;
      m := 1;
      Found := False;
      while (not Found) and (m <= McbP^.Count) do
        if McbP^.Mcbs[m].mcb >= TopSeg then
          Found := True
        else
          inc(m);

      {Mark out all mcbs associated with psp of last low memory mcb}
      TopSeg := McbP^.Mcbs[m-1].psp;
      if TopSeg <> markPsp then
        for m := 1 to McbP^.Count do
          with McbP^.Mcbs[m] do
            if psp = TopSeg then
              psp := 0;

      for b := 1 to BlockMax do
        with Blocks[b] do begin
          Found := False;
          m := 1;
          while (not Found) and (m <= McbP^.Count) do begin
            Found := (McbP^.Mcbs[m].psp <> 0) and (McbP^.Mcbs[m].mcb = mcb);
            inc(m);
          end;
          if Found then
            {was allocated at time of mark, keep it now unless a mark to be released}
            releaseIt := not KeepMark and (psp = markPsp)
          else if (mcb+1 = psp) and (memw[psp:$16] = psp)  then
            {Don't release blocks owned by master COMMAND.COM}
            releaseIt := False
          else if (psp <= $400) or (psp >= $FFF0) then
            {Don't release blocks owned by system or 386MAX}
            releaseIt := False
          else
            {not allocated at time of mark}
            releaseIt := (psp <> PrefixSeg);
        end;
    end;

  begin
    if UseHiMem then
      MarkUnallocatedBlocks
    else
      MarkBlocksAbove;

    {$IFDEF Debug}
    for b := 1 to BlockMax do
      with Blocks[b] do
        WriteLn(b:3, ' ', HexW(psp), ' ', HexW(mcb), ' ', releaseIt);
    {$ENDIF}
  end;

  function ReleaseBlock(Segm : Word) : Word; assembler;
    {-Use DOS services to release memory block}
  asm
    mov ah,$49
    mov es,Segm
    int $21
    jc  @Done
    xor ax,ax
@Done:
  end;

  procedure ReleaseMem;
    {-Release DOS memory marked for release}
  var
    B : BlockType;
  begin
    for B := BlockMax downto 1 do
      with Blocks[B] do
        if releaseIt then
          if ReleaseBlock(mcb+1) <> 0 then begin
            WriteLn('Could not release block at segment ', HexW(mcb+1));
            Abort('Memory may be a mess... Please reboot');
          end;
    MergeHiMemBlocks(HiMemSeg);
  end;

  procedure SetPSP(PSP : Word); assembler;
    {-Sets current PSP}
  asm
    mov bx,psp
    mov ax,$5000
    int $21
  end;

  procedure CloseHandles;
    {-Close any handles of blocks marked for release}
  type
    HandleTable = array[0..65520] of Byte;
  var
    O : Word;
    FileMax : Word;
    TablePtr : ^HandleTable;
    b : BlockType;
    H : Byte;
  begin
    for b := 1 to BlockMax do
      with Blocks[b] do
        if releaseIt and (psp = mcb+1) and (memw[psp:0] = $20CD) then begin
          {A released block with a program segment prefix}
          {set psp to this block}
          setpsp(psp);

          {Deal with expanded handle tables in DOS 3.0 and later}
          if DosV >= 3 then begin
            FileMax := MemW[Psp:$32];
            TablePtr := Pointer(MemL[Psp:$34]);
          end else begin
            FileMax := 20;
            TablePtr := Ptr(Psp, $18);
          end;

          for O := 0 to FileMax-1 do begin
            H := TablePtr^[O];
            case H of
              0, 1, 2, $FF : {standard handle or not open} ;
            else
              asm
                mov ah,$3E
                mov bx,O
                int $21      {ignore errors}
              end;
            end;
          end;
        end;

    {reset psp}
    setpsp(prefixseg);
  end;

  procedure RestoreEMSmap;
    {-Restore EMS to state at time of mark}
  var
    O, N, NHandle : Word;
    Status : Byte;

    procedure EmsError;
    begin
      WriteLn('Program error or EMS device not responding');
      Abort('EMS memory may be a mess... Please reboot');
    end;

    procedure MapAndFree(Handle : Word);
    var
      Status : Byte;
    begin
      Status := FreeEms(NHandle);
      if Status = $86 then
        Status := RestorePageMap(NHandle);
      if Status <> 0 then
        EmsError;
    end;

  begin
    {Get the existing EMS page map}
    GetMem(CurrEmsHandles, MaxHandles*SizeOf(HandlePageRecord));
    CurrEHandles := EmsHandles(CurrEmsHandles^);

    if CurrEHandles > MaxHandles then
      WriteLn('EMS handle count exceeds capacity of RELEASE -- no action taken')

    else if CurrEHandles <> 0 then begin
      {Compare the two maps and deallocate pages not in the stored map}
      for N := 1 to CurrEHandles do begin
        {Scan all current handles}
        NHandle := CurrEmsHandles^[N].Handle;
        if MarkEHandles > 0 then begin
          {See if current handle matches one stored by MARK}
          O := 1;
          while (MarkEmsHandles^[O].Handle <> NHandle) and (O <= MarkEHandles) do
            Inc(O);
          {If not, deallocate the current handle}
          if (O > MarkEHandles) then
            MapAndFree(NHandle);
        end else
          {No handles stored by MARK, deallocate all current handles}
          MapAndFree(NHandle);
      end;
    end;
  end;

  procedure GetOptions;
    {-Analyze command line for options}

    procedure WriteCopyright;
    begin
      WriteLn('RELEASE ', Version, ', Copyright 1993 TurboPower Software');
    end;

    procedure WriteHelp;
      {-Show the options}
    begin
      WriteCopyright;
      WriteLn;
      WriteLn('RELEASE removes memory-resident programs from memory and restores the');
      WriteLn('interrupt vectors to their state as found prior to the installation of a MARK.');
      WriteLn('RELEASE manages both normal DOS memory and also Lotus/Intel Expanded Memory.');
      WriteLn('If WATCH has been installed, RELEASE will update the WATCH data area for the');
      WriteLn('TSRs released.');
      WriteLn;
      WriteLn('RELEASE accepts the following command line syntax:');
      WriteLn;
      WriteLn('  RELEASE [MarkName] [Options]');
      WriteLn;
      WriteLn('Options may be preceded by either / or -. Valid options are as follows:');
      WriteLn;
      WriteLn('  /E         do NOT access EMS memory.');
      WriteLn('  /H         work with upper memory if available.');
      WriteLn('  /K         release memory, but keep the mark in place.');
      WriteLn('  /Q         write no screen output.');
      WriteLn('  /S chars   stuff string (<16 chars) into keyboard buffer on exit.');
      WriteLn('  /U         work with upper memory, but halt if none found.');
      WriteLn('  /?         write this help screen.');
      WriteLn;
      WriteLn('When /U is requested, a MarkName must always be specified.');
      Halt(1);
    end;

    procedure GetArgs(S : String);
    var
      SPos : Word;
      Arg : String[127];
    begin
      SPos := 1;
      repeat
        Arg := NextArg(S, SPos);
        if Arg = '' then
          Exit;
        if Arg[1] = '?' then
          WriteHelp
        else if (Arg[1] = '-') or (Arg[1] = '/') then
          case Length(Arg) of
            1 : Abort('Missing command option following '+Arg);
            2 : case UpCase(Arg[2]) of
                  '?' : WriteHelp;
                  'E' : DealWithEMS := False;
                  'H' : OptUseHiMem := True;
                  'K' : KeepMark := True;
                  'Q' : Quiet := True;
                  'S' : begin
                          Arg := NextArg(S, SPos);
                          if Length(Arg) = 0 then
                            Abort('Key string missing');
                          if Length(Arg) > 15 then
                            Abort('No more than 15 keys may be stuffed');
                          Keys := Arg+^M;
                        end;
                  'U' : UseHiMem := True;
                else
                  Abort('Unknown command option: '+Arg);
                end;
          else
            Abort('Unknown command option: '+Arg);
          end
        else
          {Named mark}
          markName := StUpcase(Arg);
      until False;
    end;

  begin
    {Initialize defaults}
    markName := '';
    Keys := '';
    ReturnCode := 0;
    TrappedBytes := 00;

    KeepMark := False;
    Quiet := False;
    DealWithEMS := True;
    UseHiMem := False;
    OptUseHiMem := False;

    {Get arguments from the command line and the environment}
    GetArgs(StringPtr(Ptr(PrefixSeg, $80))^);
    GetArgs(GetEnv('RELEASE'));

    if not Quiet then
      WriteCopyright;

    {Initialize for high memory access}
    if OptUseHiMem or UseHiMem then begin
      HiMemSeg := FindHiMemStart;
      if HiMemSeg = 0 then begin
        if UseHiMem then
          Abort('No upper memory blocks found');
      end else
        UseHiMem := True;
    end else
      HiMemSeg := 0;

    if UseHiMem then
      if MarkName = '' then
        Abort('Upper memory releases must refer to named marks');
  end;

begin
  {Analyze command line for options}
  GetOptions;

  {Get all allocated memory blocks in normal memory}
  FindTheBlocks(True, HiMemSeg, Blocks, BlockMax, StartMcb);

  {Find the last one marked with the MARK idstring, and MarkName if specified}
  if not FindMark(markName, MarkID, MarkOffset, MemMark, FilMark, markBlock) then
    Abort('No matching marker found, or protected marker encountered.');
  markPsp := Blocks[markBlock].psp;

  {Get file mark information into memory}
  if FilMark then
    ReadMarkFile(markName)
  else
    InitMarkInfo;

  {Mark those blocks to be released}
  MarkBlocks(markBlock);

  {Copy the vector table from the MARK copy}
  CopyVectors;

  {Close open file handles}
  CloseHandles;

  {Release normal memory marked for release}
  ReleaseMem;

  {Deal with expanded memory}
  if DealWithEMS then
    if EMSpresent then
      RestoreEMSmap;

  {Write success message}
  if not Quiet then begin
    Write('Memory released after MARK');
    if markName <> '' then
      Write(' (', markName, ')');
    WriteLn;
    if ReturnCode <> 0 then
      WriteLn(TrappedBytes, ' bytes temporarily trapped until batch file completes');
  end;

  {Stuff keyboard buffer if requested}
  if Length(Keys) > 0 then
    StuffKeys(Keys, True);

  NoRestoreHalt(ReturnCode);
end.